home *** CD-ROM | disk | FTP | other *** search
/ Aminet 52 / Aminet 52 (2002)(GTI - Schatztruhe)[!][Dec 2002].iso / Aminet / dev / gg / ncurses-5.3.lha / ncurses-5.3 / Ada95 / samples / sample-function_key_setting.adb < prev    next >
Text File  |  2002-10-24  |  8KB  |  215 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                       GNAT ncurses Binding Samples                       --
  4. --                                                                          --
  5. --                         Sample.Function_Key_Setting                      --
  6. --                                                                          --
  7. --                                 B O D Y                                  --
  8. --                                                                          --
  9. ------------------------------------------------------------------------------
  10. -- Copyright (c) 1998 Free Software Foundation, Inc.                        --
  11. --                                                                          --
  12. -- Permission is hereby granted, free of charge, to any person obtaining a  --
  13. -- copy of this software and associated documentation files (the            --
  14. -- "Software"), to deal in the Software without restriction, including      --
  15. -- without limitation the rights to use, copy, modify, merge, publish,      --
  16. -- distribute, distribute with modifications, sublicense, and/or sell       --
  17. -- copies of the Software, and to permit persons to whom the Software is    --
  18. -- furnished to do so, subject to the following conditions:                 --
  19. --                                                                          --
  20. -- The above copyright notice and this permission notice shall be included  --
  21. -- in all copies or substantial portions of the Software.                   --
  22. --                                                                          --
  23. -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  24. -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  25. -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  26. -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  27. -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  28. -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  29. -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  30. --                                                                          --
  31. -- Except as contained in this notice, the name(s) of the above copyright   --
  32. -- holders shall not be used in advertising or otherwise to promote the     --
  33. -- sale, use or other dealings in this Software without prior written       --
  34. -- authorization.                                                           --
  35. ------------------------------------------------------------------------------
  36. --  Author:  Juergen Pfeifer, 1996
  37. --  Contact: http://www.familiepfeifer.de/Contact.aspx?Lang=en
  38. --  Version Control
  39. --  $Revision: 1.9 $
  40. --  Binding Version 01.00
  41. ------------------------------------------------------------------------------
  42. with Ada.Unchecked_Deallocation;
  43. with Sample.Manifest; use  Sample.Manifest;
  44.  
  45. --  This package implements a simple stack of function key label environments.
  46. --
  47. package body Sample.Function_Key_Setting is
  48.  
  49.    Max_Label_Length : constant Positive := 8;
  50.    Number_Of_Keys   : Label_Number := Label_Number'Last;
  51.    Justification    : Label_Justification := Left;
  52.  
  53.    subtype Label is String (1 .. Max_Label_Length);
  54.    type Label_Array is array (Label_Number range <>) of Label;
  55.  
  56.    type Key_Environment (N : Label_Number := Label_Number'Last);
  57.    type Env_Ptr is access Key_Environment;
  58.    pragma Controlled (Env_Ptr);
  59.  
  60.    type String_Access is access String;
  61.    pragma Controlled (String_Access);
  62.  
  63.    Active_Context : String_Access := new String'("MAIN");
  64.    Active_Notepad : Panel := Null_Panel;
  65.  
  66.    type Key_Environment  (N : Label_Number := Label_Number'Last) is
  67.       record
  68.          Prev    : Env_Ptr;
  69.          Help    : String_Access;
  70.          Notepad : Panel;
  71.          Labels  : Label_Array (1 .. N);
  72.       end record;
  73.  
  74.    procedure Release_String is
  75.      new Ada.Unchecked_Deallocation (String,
  76.                                      String_Access);
  77.  
  78.    procedure Release_Environment is
  79.       new Ada.Unchecked_Deallocation (Key_Environment,
  80.                                       Env_Ptr);
  81.  
  82.    Top_Of_Stack : Env_Ptr := null;
  83.  
  84.    procedure Push_Environment (Key   : in String;
  85.                                Reset : in Boolean := True)
  86.    is
  87.       P : constant Env_Ptr := new Key_Environment (Number_Of_Keys);
  88.    begin
  89.       --  Store the current labels in the environment
  90.       for I in 1 .. Number_Of_Keys loop
  91.          Get_Soft_Label_Key (I, P.Labels (I));
  92.          if Reset then
  93.             Set_Soft_Label_Key (I, " ");
  94.          end if;
  95.       end loop;
  96.       P.Prev := Top_Of_Stack;
  97.       --  now store active help context and notepad
  98.       P.Help := Active_Context;
  99.       P.Notepad := Active_Notepad;
  100.       --  The notepad must now vanish and the new notepad is empty.
  101.       if (P.Notepad /= Null_Panel) then
  102.          Hide (P.Notepad);
  103.          Update_Panels;
  104.       end if;
  105.       Active_Notepad := Null_Panel;
  106.       Active_Context := new String'(Key);
  107.  
  108.       Top_Of_Stack := P;
  109.       if Reset then
  110.          Refresh_Soft_Label_Keys_Without_Update;
  111.       end if;
  112.    end Push_Environment;
  113.  
  114.    procedure Pop_Environment
  115.    is
  116.       P : Env_Ptr := Top_Of_Stack;
  117.    begin
  118.       if Top_Of_Stack = null then
  119.          raise Function_Key_Stack_Error;
  120.       else
  121.          for I in 1 .. Number_Of_Keys loop
  122.             Set_Soft_Label_Key (I, P.Labels (I), Justification);
  123.          end loop;
  124.          pragma Assert (Active_Context /= null);
  125.          Release_String (Active_Context);
  126.          Active_Context := P.Help;
  127.          Refresh_Soft_Label_Keys_Without_Update;
  128.          Notepad_To_Context (P.Notepad);
  129.          Top_Of_Stack := P.Prev;
  130.          Release_Environment (P);
  131.       end if;
  132.    end Pop_Environment;
  133.  
  134.    function Context return String
  135.    is
  136.    begin
  137.       if Active_Context /= null then
  138.          return Active_Context.all;
  139.       else
  140.          return "";
  141.       end if;
  142.    end Context;
  143.  
  144.    function Find_Context (Key : String) return Boolean
  145.    is
  146.       P : Env_Ptr := Top_Of_Stack;
  147.    begin
  148.       if Active_Context.all = Key then
  149.          return True;
  150.       else
  151.          loop
  152.             exit when P = null;
  153.             if P.Help.all = Key then
  154.                return True;
  155.             else
  156.                P := P.Prev;
  157.             end if;
  158.          end loop;
  159.          return False;
  160.       end if;
  161.    end Find_Context;
  162.  
  163.    procedure Notepad_To_Context (Pan : in Panel)
  164.    is
  165.       W : Window;
  166.    begin
  167.       if Active_Notepad /= Null_Panel then
  168.          W := Get_Window (Active_Notepad);
  169.          Clear (W);
  170.          Delete (Active_Notepad);
  171.          Delete (W);
  172.       end if;
  173.       Active_Notepad := Pan;
  174.       if Pan /= Null_Panel then
  175.          Top  (Pan);
  176.       end if;
  177.       Update_Panels;
  178.       Update_Screen;
  179.    end Notepad_To_Context;
  180.  
  181.    procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style;
  182.                          Just : Label_Justification := Left)
  183.    is
  184.    begin
  185.       case Mode is
  186.          when PC_Style .. PC_Style_With_Index
  187.            => Number_Of_Keys := 12;
  188.          when others
  189.            => Number_Of_Keys := 8;
  190.       end case;
  191.       Init_Soft_Label_Keys (Mode);
  192.       Justification := Just;
  193.    end Initialize;
  194.  
  195.    procedure Default_Labels
  196.    is
  197.    begin
  198.       Set_Soft_Label_Key (FKEY_QUIT, "Quit");
  199.       Set_Soft_Label_Key (FKEY_HELP, "Help");
  200.       Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys");
  201.       Refresh_Soft_Label_Keys_Without_Update;
  202.    end Default_Labels;
  203.  
  204.    function Notepad_Window return Window
  205.    is
  206.    begin
  207.       if Active_Notepad /= Null_Panel then
  208.          return Get_Window (Active_Notepad);
  209.       else
  210.          return Null_Window;
  211.       end if;
  212.    end Notepad_Window;
  213.  
  214. end Sample.Function_Key_Setting;
  215.